home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / blt1.000 / blt1 / blt-1.7-for-STk / demos / busy.stk < prev    next >
Encoding:
Text File  |  1994-07-26  |  4.1 KB  |  148 lines
  1. #!../test-blt -f
  2. ;;;;
  3. ;;;; Script to test the "busy" command.
  4. ;;;; 
  5. (require "blt")
  6. ;;;;
  7. ;;;; General widget class resource attributes
  8. ;;;;
  9. (option 'add "*Button.padX"     10)
  10. (option 'add "*Button.padY"     2)
  11. (option 'add "*Scale.relief"     'sunken)
  12. (option 'add "*Scale.orient"    'horizontal)
  13. (option 'add "*Entry.relief"     'sunken)
  14.  
  15.  
  16. (define activeBg 'red)
  17. (define normalBg 'springgreen)
  18. (define bitmapFg 'blue)
  19. (define bitmapBg 'green)
  20.  
  21. (let ((visual (winfo 'screenvisual *root*))) 
  22.   (when (or (eq? visual 'staticgray) (eq? visual 'grayscale))
  23.     (set! activeBg black)
  24.     (set! normalBg white)
  25.     (set! bitmapFg black)
  26.     (set! bitmapBg white)))
  27.  
  28. ;;;;
  29. ;;;; Instance specific widget options
  30. ;;;;
  31. (option 'add "STk.top.relief"         'sunken)
  32. (option 'add "STk.top.borderWidth"     4)
  33. (option 'add "STk.top.background"     normalBg)
  34. (option 'add "STk.b1.text"         "Test")
  35. (option 'add "STk.b2.text"         "Quit")
  36. (option 'add "STk.b3.text"         "New button")
  37. (option 'add "STk.b4.text"         "Hold")
  38. (option 'add "STk.b4.background"     activeBg)
  39. (option 'add "STk.b4.foreground"     normalBg)
  40. (option 'add "STk.b5.text"         "Release")
  41. (option 'add "STk.b5.background"     normalBg)
  42. (option 'add "STk.b5.foreground"     activeBg)
  43.  
  44. ;;;;
  45. ;;;; This never gets used; it's reset by the Animate proc. It's 
  46. ;;;; here to just demonstrate how to set busy window options via
  47. ;;;; the host window path name
  48. ;;;;
  49. (option 'add "STk.top.busyCursor"     'bogosity)
  50.  
  51. ;;;;
  52. ;;;; Initialize a list bitmap file names which make up the animated 
  53. ;;;; fish cursor. The bitmap mask files have a "m" appended to them.
  54. ;;;;
  55. (define bitmaps '(fc_left fc_left1 fc_mid fc_right1 fc_right))
  56.  
  57. ;;;;
  58. ;;;; Counter for new buttons created by the "New button" button
  59. ;;;;
  60. (define numWin 0)
  61. ;;;;
  62. ;;;; Current index into the bitmap list. Indicates the current cursor.
  63. ;;;; If -1, indicates to stop animating the cursor.
  64. ;;;;
  65. (define cnt -1)
  66.  
  67. ;;;;
  68. ;;;; Create two frames. The top frame will be the host window for the
  69. ;;;; busy window.  It'll contain widgets to test the effectiveness of
  70. ;;;; the busy window.  The bottom frame will contain buttons to 
  71. ;;;; control the testing.
  72. ;;;;
  73. (frame '.top)
  74. (frame '.bottom)
  75.  
  76. ;;;;
  77. ;;;; Create some widgets to test the busy window and its cursor
  78. ;;;;
  79. (button '.b1 :command '(display "Not busy.\n"))
  80. (button '.b2 :command '(destroy *root*))
  81. (entry '.e1) 
  82. (scale '.s1)
  83.  
  84. ;;;;
  85. ;;;; The following buttons sit in the lower frame to control the demo
  86. ;;;;
  87. (button '.b3 :command '(begin
  88.              (set! numWin (+ numWin 1))
  89.              (let* ((name (format #f "button#~A" numWin))
  90.                 (widg (& .top "." name)))
  91.                (button widg
  92.                    :text name
  93.                    :command `(format #t "I am ~A\n" ,name))
  94.                (pack widg :expand #t :padx 10 :pady 10))))
  95. (button '.b4 :command '(begin
  96.              (blt_busy '.top :in *root*)
  97.              (focus 'none)
  98.              (when (< cnt 0)
  99.                    (tk-set! .top :bg activeBg)
  100.                    (set! cnt 0)
  101.                    (Animate .top))))
  102. (button '.b5 :command '(begin
  103.              (catch (blt_busy 'release '.top))
  104.              (set! cnt -1)
  105.              (tk-set! .top :bg normalBg)))
  106.  
  107. ;;;;
  108. ;;;; Notice that the widgets packed in .top and .bottom are not their children
  109. ;;;;
  110. (pack .b1 .e1 .s1 .b2 :in .top    :expand #t :padx 10 :pady 10)
  111. (pack .b3 .b4 .b5     :in .bottom :expand #t :padx 10 :pady 10)
  112.  
  113.  
  114. ;;;;
  115. ;;;; Finally, realize and map the top level window
  116. ;;;;
  117. (pack .top  .bottom :expand #t)
  118.  
  119. ;;;;
  120. ;;;; Simple cursor animation routine: Uses the "after" command to 
  121. ;;;; circulate through a list of cursors every 0.075 seconds. The
  122. ;;;; first pass through the cursor list may appear sluggish because 
  123. ;;;; the bitmaps have to be read from the disk.  Tk's cursor cache
  124. ;;;; takes care of it afterwards.
  125. ;;;;
  126. (define (Animate w)
  127.   (if (>= cnt 0)
  128.       [let* ((name (list-ref bitmaps cnt))
  129.          (src  (format #f "@bitmaps/~A"  name))
  130.          (mask (format #f "bitmaps/~Am" name)))
  131.     (blt_busy 'configure w :cursor (format #f "~A ~A ~A ~A"
  132.                            src mask bitmapFg bitmapBg))
  133.     (set! cnt (modulo (+ cnt 1) 5))
  134.     (after 75 `(Animate ,w))]
  135.       [blt_busy 'configure w :cursor 'watch]))
  136.  
  137.  
  138. ;;;;
  139. ;;;; For testing purposes allow the top level window to be resized 
  140. ;;;;
  141. (wm 'min *root* 0 0)
  142.  
  143. ;;;;
  144. ;;;; If the "raise" window command exists, force the demo to stay raised
  145. ;;;;
  146. (if (symbol-bound? 'raise)
  147.     (bind *root* "<Visibility>" '(raise "%W")))
  148.